Night Owl 6/Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso/029a/qbtree51.zip/XAPP1.BAS

BASIC Source File | 1991-04-07 | 14KB | 408 lines

DECLARE SUB MoveIn (rec$, vseg%, voff%)
DECLARE FUNCTION MoveOut$ (vseg%, voff%, bytes%)
DECLARE FUNCTION Prepare$ (vseg%, voff%, bytes%)
DECLARE FUNCTION OpenXAppFiles% ()
DECLARE FUNCTION BuildXAppFiles% ()
DECLARE FUNCTION ShowXAppFiles% ()
DECLARE FUNCTION CreateXAppFiles% ()

DEFINT A-Z
REM $INCLUDE: 'qbtree50.bi'

'XAPP.BAS - an example application that exercises QBTREE.
'(C)1991 Cornel Huth
'07-Apr-1991
'
'------------------------------- DESCRIPTION --------------------------------
'
' A) Primary key in EMP.DAT is EMP#. For each employee there is one and only
' one EMP# and for each EMP# there is one and only one employee. Each
' employee is assigned to a department. EMP.DAT:DEPT#, the foreign key,
' contains the department number he is assigned to.
'
' Given an employee number (in EMP.DAT) you can find which department he is
' assigned. You can also find the name of his manager.
'
'
' B) Primary key in DEP.DAT is DEPT#. For each department there is one and
' only one DEPT# and for each DEPT# there is one and only one department.
' DEP.DAT:MGR#, the foreign key, contains the employee number of that
' department's manager.
'
' Given a department number (in DEP.DAT) you can find the name of the
' manager of that department.
'
'
' C) Primary key in DEPEMP.DAT is DEP#+EMP#. Since each DEP# is unique and
' each EMP# is unique, combining the two you get a unique key. The DEP#
' portion of the key groups all EMP#'s in DEP# together allowing you to get
' all EMP#'s in a particular DEP#.
'
' Given a department number (in DEPEMP.DAT) you can find all employees in
' that department. To get a unique primary key, the employee number is
' combined with the department number. With QBTREE you can specify a
' partial key (in this case just DEPT# with an EMP# of 0) and QBTREE will
' return the first DEPT#+EMP#. Using GetNext() you continue processing
' this until the DEPT# portion changes.
'
'
'  ====  Primary key (field used to index this file)
'
'  ----  Foreign key (field used to connect to another file's primary key)
'
'  ≡≡≡≡  Used as both primary and foreign key
'
'                                               C) DEPEMP.DAT RECORD*
'                                                 ┌───────┬──────┐
'   ┌────────────────────────────── ─────┐         │ DEPT# │ EMP# │
'   │                                    │         │ ===== │ ≡≡≡≡ │
'     A) EMP.DAT RECORD                 │         └───────┴──────┘
'┌──────┬───────────────┬────────┬────┐  └────────────────────┘
'│ EMP# │ EMPLOYEE NAME │ DEPT#  │ WG │
'│ ==== │               │ -----  │    │     B) DEP.DAT RECORD
'└──────┴───────────────┴────────┴────┘   ┌───────┬───────────┬──────┐
'                          │             │ DEPT# │ DEPT NAME │ MGR# │
'   │                       └─────────── │ ====  │           │ ---- │
'   │                                     └───────┴───────────┴──────┘
'   │                                                            │
'   └────────────────────────────────────────────────────────────┘
'
' Example datafile contents:
'
'            EMP.DAT                  DEP.DAT        DEPEMP.DAT*
'  EMP# EMPLOYEE NAME   D# WG    D# DEPT NAME  MGR#    D# EMP#
'  ---- --------------- -- --    -- ---------- ----    -- ----
'  1001 Frank Haas      12 15    10 Purchasing 1002    10 1002
'  1002 Wendy Gibson    10 15    11 Accounting 2173    11 2173
'  1125 Willie McAffee  14  9    12 Legal      1001    12 1001
'  1507 David Robinson  13  9    13 MIS        1507    13 1507
'  2173 Jackie Stewart  11 17    14 Personnel  1125    14 1125
'  ... and so on                 ... and so on         ... and so on
'
' * DEPEMP.DAT carries no information other than the DEP# in DEP.DAT
' and the EMP# in EMP.DAT. This means we do not need to carry a data
' file for the DEPEMP information. What is listed in this description
' as DEPEMP.DAT will actually be the index file itself (DEPEMP.NDX).
'----------------------------------------------------------------------------
'
' This program will output to the screen two logical tables. Table 1, the
' BY EMPLOYEE table, will have the employee's number, name, wage grade,
' department, and manager. Table 2, the BY DEPARTMENT table, will have a list of
' employees in each department.
'
'============================================================================

' QBTREE file number equates
CONST EMPdf = 0         'EMP.DAT QBTREE data file number
CONST DEPdf = 1         'DEP.DAT
CONST MDF = 1           'max data files needed (last data file number)

CONST EMPif = 0         'EMP.NDX QBTREE index file number
CONST DEPif = 1         'DEP.NDX
CONST DEPEMPif = 2      'DEPEMP.NDX
CONST MKF = 2           'max key files needed (last key file number)

' Employee data record type
TYPE EmpDataTYPE
Number AS STRING * 4
Name AS STRING * 15
DeptNo AS STRING * 2
WG AS INTEGER
END TYPE '23
DIM SHARED EMP AS EmpDataTYPE

' Department data record type
TYPE DepDataTYPE
Number AS STRING * 2
Name AS STRING * 10
MgrNo AS STRING * 4
END TYPE '16
DIM SHARED DEP AS DepDataTYPE

'size FixedStr to largest TYPE structure used in QBTREE access
DIM SHARED FixedStr AS STRING * 23

DIM SHARED XEmpData$
DIM SHARED XDepData$
DIM SHARED XEmpIndex$
DIM SHARED XDepIndex$
DIM SHARED XDepEmpIndex$

' We'll create 3 key files and 2 data files using the info from the
' DATA statements below. Once built we'll show two tables based on the data

CLS
stat = InitQBTREE(MKF, MDF)
IF stat = 0 THEN
   stat = CreateXAppFiles
   IF stat = 0 THEN
      stat = OpenXAppFiles
      IF stat = 0 THEN
         stat = BuildXAppFiles
         IF stat = 0 THEN
            stat = ShowXAppFiles
            IF stat THEN
               PRINT "Error"; stat; "from ShowXAppFiles"
            END IF
         ELSE
            PRINT "Error"; stat; "from BuildXAppFiles"
         END IF
      ELSE
         PRINT "Error"; stat; "from OpenXAppFiles"
      END IF
   ELSE
      PRINT "Error"; stat; "from CreateXAppFiles"
   END IF
ELSE
   PRINT "Error"; stat; "from InitQBTREE"
END IF
nul = ExitQBTREE
END


' We'll use DATA statements to simplify getting the initial data

' XApp employee data
EmpData:
DATA 11
DATA 1001,Frank Hass,12,15
DATA 1002,Wendy Gibson,10,15
DATA 1125,Willie McAffee,14,9
DATA 1507,David Robinson,13,9
DATA 1173,Jackie Stewart,11,17
DATA 4105,Beatrice South,10,5
DATA 4288,Jim Davies,10,5
DATA 4901,Tom Cassidy,14,4
DATA 3149,Nancy Cannon,13,7
DATA 3510,John Madison,12,12
DATA 3685,Chris Ho,13,9

' XApp department data
DepData:
DATA 5
DATA 10,Purchasing,1002
DATA 11,Accounting,1173
DATA 12,Legal,1001
DATA 13,MIS,1507
DATA 14,Personnel,1125

FUNCTION BuildXAppFiles

'using the info in the DATA statements build the XApp files

PRINT "Building employee data and index files...";
RESTORE EmpData
READ EmpRecs
FOR i = 1 TO EmpRecs
   READ EMP.Number, EMP.Name, EMP.DeptNo, EMP.WG
   key$ = EMP.Number
   rec$ = MoveOut$(VARSEG(EMP), VARPTR(EMP), LEN(EMP))
   stat = AddKeyRecord(EMPif, EMPdf, key$, rec$)
   IF stat THEN EXIT FOR
NEXT
IF stat = 0 THEN
   PRINT "ok."
   PRINT "Building department data and index files...";
   RESTORE DepData
   READ DepRecs
   FOR i = 1 TO DepRecs
      READ DEP.Number, DEP.Name, DEP.MgrNo
      key$ = DEP.Number
      rec$ = MoveOut$(VARSEG(DEP), VARPTR(DEP), LEN(DEP))
      stat = AddKeyRecord(DEPif, DEPdf, key$, rec$)
      IF stat THEN EXIT FOR
   NEXT
   IF stat = 0 THEN
      PRINT "ok."
      PRINT "Building department+employee index file...";

      ' to build this index file we use the employee file just built.
      ' a shortcoming of this is that departments with no employees
      ' (unlikely) assigned will not be represented in the index file.

      recno& = 0 'we won't be needing data record pointers for StoreKey()

      stat = GetFirst(EMPif, EMPdf, key$, rec$)
      DO WHILE stat = 0

         'rec$ contains employee data record info, move it to EMP structure
         MoveIn rec$, VARSEG(EMP), VARPTR(EMP)

         'EMP.DeptNo and EMP.Number are string so we can forego MoveOut$()
         key$ = EMP.DeptNo + EMP.Number

         stat = StoreKey(DEPEMPif, key$, recno&)
         IF stat = 0 THEN stat = GetNext(EMPif, EMPdf, key$, rec$)
      LOOP
      IF stat = 202 THEN stat = 0  'End of file is expected
      IF stat = 0 THEN PRINT "ok."

   END IF
END IF
BuildXApp = stat

END FUNCTION

FUNCTION CreateXAppFiles

' Create the XApp files. If they already exist delete them first.

PRINT "Creating XApp Files...";

XEmpData$ = "EMP.DAT"
XDepData$ = "DEP.DAT"
XEmpIndex$ = "EMP.NDX"
XDepIndex$ = "DEP.NDX"
XDepEmpIndex$ = "DEPEMP.NDX"

IF FileExists(XEmpData$) THEN KILL XEmpData$
IF FileExists(XDepData$) THEN KILL XDepData$
IF FileExists(XEmpIndex$) THEN KILL XEmpIndex$
IF FileExists(XDepIndex$) THEN KILL XDepIndex$
IF FileExists(XDepEmpIndex$) THEN KILL XDepEmpIndex$

stat = CreateDataFile(XEmpData$, LEN(EMP))
IF stat = 0 THEN stat = CreateDataFile(XDepData$, LEN(DEP))
IF stat = 0 THEN stat = CreateKeyFile(XEmpIndex$, LEN(EMP.Number))
IF stat = 0 THEN stat = CreateKeyFile(XDepIndex$, LEN(DEP.Number))
IF stat = 0 THEN stat = CreateKeyFile(XDepEmpIndex$, LEN(EMP.Number) + LEN(DEP.Number))

IF stat = 0 THEN PRINT "ok."
CreateXAppFiles = stat

END FUNCTION

SUB MoveIn (rec$, vseg, voff)

' copy the variable-length string data from rec$ (which may contain
' non-string data) to the TYPEd structure pointed to by vseg:voff.
' See MoveOut$() for more.

FixedStr = rec$
MEMCOPY VARSEG(FixedStr), VARPTR(FixedStr), vseg, voff, LEN(rec$)

END SUB

FUNCTION MoveOut$ (vseg, voff, bytes)

' copy the data from the TYPEd structure pointed to by vseg:voff
' to a fixed-length string. We use a fixed-length string so that
' we don't need to concern ourselves with being both QB4 and PDS /Fs
' compatible. Simple fixed-length strings are in DGROUP for both
' QB and QBX. Note: FixedStr needs to be sized to at least the largest
' TYPE structure size (23 bytes for XEmpData).

'IF bytes > LEN(FixedStr) THEN STOP  'useful in debugging stage

MEMCOPY vseg, voff, VARSEG(FixedStr), VARPTR(FixedStr), bytes
MoveOut$ = LEFT$(FixedStr, bytes)

END FUNCTION

FUNCTION OpenXAppFiles

PRINT "Opening XApp Files...";

stat = OpenDataFile(XEmpData$, EMPdf)
IF stat = 0 THEN stat = OpenDataFile(XDepData$, DEPdf)
IF stat = 0 THEN stat = OpenKeyFile(XEmpIndex$, EMPif)
IF stat = 0 THEN stat = OpenKeyFile(XDepIndex$, DEPif)
IF stat = 0 THEN stat = OpenKeyFile(XDepEmpIndex$, DEPEMPif)

IF stat = 0 THEN PRINT "ok."
OpenXAppFiles = stat

END FUNCTION

FUNCTION ShowXAppFiles

CLS
PRINT "****************** BY EMPLOYEE ********************"
PRINT
PRINT "EMP#     EMPLOYEE      GRADE  DEPARTMENT       MANAGER"
PRINT "----  ---------------   ---   ----------   ---------------"

' get the first employee's info
stat = GetFirst(EMPif, EMPdf, key$, rec$)
DO WHILE stat = 0

   ' move the employee record data to the EMP structure
   MoveIn rec$, VARSEG(EMP), VARPTR(EMP)
   LastKey$ = EMP.Number
   PRINT EMP.Number;
   LOCATE , 7: PRINT EMP.Name;
   t$ = SPACE$(3)
   RSET t$ = STR$(EMP.WG)       'right-align wage grade
   LOCATE , 24: PRINT t$;

   ' go get the department info for this employee
   stat = GetEqual(DEPif, DEPdf, EMP.DeptNo, rec$)
   IF stat = 0 THEN

      ' move department record data to the DEP structure
      MoveIn rec$, VARSEG(DEP), VARPTR(DEP)
      LOCATE , 31: PRINT DEP.Name;

      ' go get the manager's name
      stat = GetEqual(EMPif, EMPdf, DEP.MgrNo, rec$)
      IF stat = 0 THEN

          ' move manager's record data to EMP structure (he is an employee)
          MoveIn rec$, VARSEG(EMP), VARPTR(EMP)
          LOCATE , 44: PRINT EMP.Name
      END IF

      ' we need to reposition to the last employee (getting the manager's
      ' name messed things up a bit) and then get the next employee
      stat = GetEqual(EMPif, EMPdf, LastKey$, rec$)
      IF stat = 0 THEN stat = GetNext(EMPif, EMPdf, key$, rec$)

   END IF
LOOP
IF stat = 202 THEN stat = 0

IF stat = 0 THEN
   PRINT
   PRINT "******************************** BY DEPARTMENT *******************************"
   PRINT
   PRINT "  Purchasing      Accounting         Legal           MIS          Personnel"
   PRINT "--------------- --------------- --------------- -------------- ---------------"
   p10 = CSRLIN: p11 = p10: p12 = p10: p13 = p10: p14 = p10

   stat = RetrieveFirst(DEPEMPif, key$, recno&)
   DO WHILE stat = 0

      ' we know that the EMP# is bytes 3-6 of the key so
      ' get the name of this EMP# (DEP# is bytes 1-2)
      Dept$ = LEFT$(key$, 2)
      Ekey$ = MID$(key$, 3, 4)
      stat = GetEqual(EMPif, EMPdf, Ekey$, Erec$)
      MoveIn Erec$, VARSEG(EMP), VARPTR(EMP)

      SELECT CASE Dept$
      CASE "10"
         LOCATE p10, 1
         p10 = p10 + 1
      CASE "11"
         LOCATE p11, 17
         p11 = p11 + 1
      CASE "12"
         LOCATE p12, 33
         p12 = p12 + 1
      CASE "13"
         LOCATE p13, 49
         p13 = p13 + 1
      CASE "14"
         LOCATE p14, 64
         p14 = p14 + 1
      CASE ELSE
      END SELECT
      PRINT EMP.Name

      stat = RetrieveNext(DEPEMPif, key$, recno&)
   LOOP
END IF

END FUNCTION